home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / scmactst < prev    next >
Text File  |  1993-09-27  |  3KB  |  139 lines
  1. ;;;;From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson
  2.  
  3. (require 'test)
  4. (require 'syntactic-closures)
  5.  
  6. (macro:expand
  7.  '(define-syntax push
  8.     (syntax-rules ()
  9.           ((push item list)
  10.            (set! list (cons item list))))))
  11.  
  12. (test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo)))
  13.  
  14. (macro:expand
  15.  '(define-syntax push1
  16.     (transformer
  17.      (lambda (exp env)
  18.        (let ((item
  19.           (make-syntactic-closure env '() (cadr exp)))
  20.          (list
  21.           (make-syntactic-closure env '() (caddr exp))))
  22.      `(set! ,list (cons ,item ,list)))))))
  23.  
  24. (test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo)))
  25.  
  26. (macro:expand
  27.  '(define-syntax loop
  28.     (transformer
  29.      (lambda (exp env)
  30.        (let ((body (cdr exp)))
  31.      `(call-with-current-continuation
  32.        (lambda (exit)
  33.          (let f ()
  34.            ,@(map (lambda  (exp)
  35.             (make-syntactic-closure env '(exit)
  36.                         exp))
  37.               body)
  38.            (f)))))))))
  39.  
  40. (macro:expand
  41.  '(define-syntax let1
  42.     (transformer
  43.      (lambda (exp env)
  44.        (let ((id (cadr exp))
  45.          (init (caddr exp))
  46.          (exp (cadddr exp)))
  47.      `((lambda (,id)
  48.          ,(make-syntactic-closure env (list id) exp))
  49.        ,(make-syntactic-closure env '() init)))))))
  50.  
  51. (test 93 'let1 (macro:eval '(let1 a 90 (+ a 3))))
  52.  
  53. (macro:expand
  54.  '(define-syntax loop-until
  55.     (syntax-rules
  56.      ()
  57.      ((loop-until id init test return step)
  58.       (letrec ((loop
  59.         (lambda (id)
  60.           (if test return (loop step)))))
  61.     (loop init))))))
  62.  
  63. (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
  64.                (loop 3)))
  65.       'loop
  66.       (macro:expand '(loop-until foo 3 #t 12 33)))
  67.  
  68. (macro:expand
  69.  '(define-syntax loop-until1
  70.     (transformer
  71.      (lambda (exp env)
  72.        (let ((id (cadr exp))
  73.          (init (caddr exp))
  74.          (test (cadddr exp))
  75.          (return (cadddr (cdr exp)))
  76.          (step (cadddr (cddr exp)))
  77.          (close
  78.           (lambda (exp free)
  79.         (make-syntactic-closure env free exp))))
  80.      `(letrec ((loop
  81.             ,(capture-syntactic-environment
  82.               (lambda (env)
  83.             `(lambda (,id)
  84.                (,(make-syntactic-closure env '() `if)
  85.                 ,(close test (list id))
  86.                 ,(close return (list id))
  87.                 (,(make-syntactic-closure env '()
  88.                               `loop)
  89.                  ,(close step (list id)))))))))
  90.         (loop ,(close init '()))))))))
  91.  
  92. (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
  93.                   (loop 3)))
  94.       'loop1
  95.       (macro:expand '(loop-until1 foo 3 #t 12 33)))
  96.  
  97. (test '#t 'identifier (identifier? 'a))
  98. ;;; this needs to setup ENV.
  99. ;;;(test '#t 'identifier
  100. ;;;      (identifier? (macro:expand (make-syntactic-closure env '() 'a))))
  101. (test #f 'identifier (identifier? "a"))
  102. (test #f 'identifier (identifier? #\a))
  103. (test #f 'identifier (identifier? 97))
  104. (test #f 'identifier (identifier? #f))
  105. (test #f 'identifier (identifier? '(a)))
  106. (test #f 'identifier (identifier? '#(a)))
  107.  
  108. (test '(#t #f)
  109.       'syntax
  110.       (macro:eval
  111.        '(let-syntax
  112.         ((foo
  113.           (transformer
  114.            (lambda (form env)
  115.          (capture-syntactic-environment
  116.           (lambda (transformer-env)
  117.             (identifier=? transformer-env 'x env 'x)))))))
  118.       (list (foo)
  119.         (let ((x 3))
  120.           (foo))))))
  121.  
  122.  
  123. (test '(#f #t)
  124.       'syntax
  125.       (macro:eval
  126.        '(let-syntax ((bar foo))
  127.       (let-syntax
  128.           ((foo
  129.         (transformer
  130.          (lambda (form env)
  131.            (capture-syntactic-environment
  132.             (lambda (transformer-env)
  133.               (identifier=? transformer-env 'foo
  134.                     env (cadr form))))))))
  135.         (list (foo foo)
  136.           (foo bar))))))
  137.  
  138. (report-errs)
  139.